C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
 
 
 
 
 
 
 
 
C                                   parameter length
 
 
 
 
 
 
 
 
 
C following are for ZYCSDT (Canonicalise Symbol Data Types)
C ----------------------------------------------------------------------
C
C       Z Y A D N X   -   Add a node next to this one
C
C       (Make N1 come next  to (i.e. after) N2).
C
 
        SUBROUTINE ZYADNX(N1,N2)
        INTEGER N1,N2
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        INTEGER N2SUC
 
        INTEGER NEXT,PREV,UP,DOWN,NTYPE,NODE
 
        NEXT(NODE)=MOD(TREE(3,NODE),46340)
        PREV(NODE)=(TREE(3,NODE)/46340)
        UP(NODE)=(TREE(1,NODE)/46340)
        DOWN(NODE)=TREE(2,NODE)
        NTYPE(NODE)=MOD(TREE(1,NODE),46340)
 
        N2SUC=N2
 100    N2SUC=PREV(N2SUC)
        IF (PREV(N2SUC).NE.N2) GO TO 100
        IF (UP(N1).NE.0) CALL ZYDELT(N1)
        TREE(3,N1)=N2*46340+NEXT(N2)
        TREE(1,N1)=UP(N2)*46340+NTYPE(N1)
        TREE(3,N2SUC)=N1*46340+NEXT(N2SUC)
        TREE(3,N2)=PREV(N2)*46340+N1
 
        END
C ----------------------------------------------------------------------
C
C       Z Y A S T R   -   Add string to the string table
C
 
        INTEGER FUNCTION ZYASTR(TEXT)
        INTEGER TEXT(*)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
        INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
 
        SAVE /XCSTRI/
 
 
        INTEGER I,L
        LOGICAL MATCH
 
        INTEGER EQUAL,LENGTH
        EXTERNAL EQUAL,LENGTH,SCOPY,ERROR
 
        I=0
        L=LENGTH(TEXT)
        IF (NSTRNG.EQ.7103) CALL ERROR('Too many strings')
        IF (TXTTOP+L+1.GE.46339)
     +      CALL ERROR('String area overflowed')
 
 100    I=I+1
        MATCH=EQUAL(STRTXT(STRTBL(I)),TEXT).EQ.-2
        IF (I.LT.NSTRNG .AND. .NOT. MATCH) GOTO 100
 
        IF (MATCH) THEN
            ZYASTR=STRTBL(I)
        ELSE
            ZYASTR=TXTTOP
            NSTRNG=NSTRNG+1
            STRTBL(NSTRNG)=TXTTOP
            CALL SCOPY(TEXT,1,STRTXT,TXTTOP)
            TXTTOP=TXTTOP+LENGTH(TEXT)+1
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       Z Y A S Y M   -   Add (maybe) a new symbol
C                         (return pointer to old symbol if any)
C
 
        INTEGER FUNCTION ZYASYM(STRPTR,PUN,SYMTYP)
        INTEGER SYMTYP,PUN,STRPTR
 
        INTEGER I
        LOGICAL CBLK,NOTFND
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        EXTERNAL ERROR
 
        CBLK=SYMTYP.EQ.2
        ZYASYM=PUIDX(MIN(PUN,NPUS,250))
        NOTFND=.TRUE.
 
C Find first symbol of program-unit
 100    IF (SYMBOL(3,ZYASYM).LT.PUN) THEN
            ZYASYM=ZYASYM+1
            IF (ZYASYM.LE.NSYMS) GOTO 100
            CALL ERROR('ZYASYM: Couldn''t find program unit')
        END IF
 
C Try to find the symbol we want to insert
 200    IF (ZYASYM.LE.NSYMS) THEN
            IF (SYMBOL(2,ZYASYM).EQ.STRPTR .AND.
     +          SYMBOL(3,ZYASYM).EQ.PUN .AND.
     +          (CBLK.EQV.SYMBOL(1,ZYASYM).EQ.2)) THEN
                NOTFND=.FALSE.
            ELSE
                ZYASYM=ZYASYM+1
                IF (SYMBOL(3,ZYASYM-1).EQ.PUN) GOTO 200
C If symbol table has been modified, there might be extra symbols for
C this program-unit added after the beginning of the next ...
                IF (MODFLG) GOTO 200
            END IF
        END IF
        IF (NOTFND) THEN
            IF (NSYMS.EQ.5003) CALL ERROR('Too many symbols')
            NSYMS=NSYMS+1
            MODFLG=.TRUE.
            SYMBOL(1,NSYMS)=SYMTYP
            SYMBOL(2,NSYMS)=STRPTR
            SYMBOL(3,NSYMS)=PUN
            DO 300 I=4,8
 300            SYMBOL(I,NSYMS)=0
            ZYASYM=NSYMS
        ELSE
            IF (SYMTYP.NE.3 .AND. SYMBOL(1,ZYASYM).NE.SYMTYP .AND.
     +          (SYMTYP.NE.5 .OR. SYMBOL(1,ZYASYM).NE.4))
     +          CALL ZYSERR('Inconsistent symbol types',ZYASYM,.TRUE.)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       Z Y C A T T   -   Check symbol Attribute (set it if zero)
C
 
        SUBROUTINE ZYCATT(SYMPTR,ATTNUM,VALUE)
        INTEGER SYMPTR,ATTNUM,VALUE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        IF (SYMBOL(ATTNUM,SYMPTR).NE.VALUE .AND.
     +      SYMBOL(ATTNUM,SYMPTR).NE.0) THEN
            CALL ZYSERR('Inconsistent symbol attributes',SYMPTR,.FALSE.)
        ELSE
            SYMBOL(ATTNUM,SYMPTR)=VALUE
        ENDIF
 
        END
C ----------------------------------------------------------------------
C
C       Z Y C H D N   -   Change down pointer
C
 
        SUBROUTINE ZYCHDN(NODE,DOWN)
        INTEGER NODE,DOWN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        TREE(2,NODE)=DOWN
 
        END
C ----------------------------------------------------------------------
C
C       Z Y C H N T   -   Change node type
C
 
        SUBROUTINE ZYCHNT(NODE,TYPE)
        INTEGER NODE,TYPE
 
        INTRINSIC INT
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        TREE(1,NODE)=INT(TREE(1,NODE)/46340)*46340+TYPE
 
        END
C ----------------------------------------------------------------------
C
C       Z Y C R N D   -   Create a new node in the parse tree
C
 
C
C Note: when a new node is created, it has the status "deleted", ie the
C       up pointer is zero, next is zero, prev is a backlink.
C
C
 
        INTEGER FUNCTION ZYCRND(TYPE,DOTTIR)
        INTEGER TYPE,DOTTIR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        INTEGER PTR
 
        EXTERNAL ERROR
 
        IF (TRETOP.EQ.46339) CALL ERROR('Parse tree overflowed')
        TRETOP=TRETOP+1
        TREE(1,TRETOP)=TYPE
        TREE(2,TRETOP)=DOTTIR
        TREE(3,TRETOP)=TRETOP*46340
        TREE(4,TRETOP)=0
        IF (DOTTIR.GT.0) THEN
            PTR=DOTTIR
 100        TREE(1,PTR)=MOD(TREE(1,PTR),46340)+TRETOP*46340
            PTR=MOD(TREE(3,PTR),46340)
            IF (PTR.GT.0) GO TO 100
        END IF
        ZYCRND=TRETOP
 
        END
C ----------------------------------------------------------------------
C
C       Z Y D E L T   -   Delete (sub)Tree
C
 
        SUBROUTINE ZYDELT(SBROOT)
        INTEGER SBROOT
 
        INTEGER SUC,P
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
        P=PREV(SBROOT)
        SUC=SBROOT
 100    SUC=PREV(SUC)
        IF (PREV(SUC).NE.SBROOT) GO TO 100
        TREE(3,SUC)=NEXT(SUC)+46340*P
        IF (DOWN(UP(SBROOT)).EQ.SBROOT) TREE(2,UP(SBROOT))=NEXT(SBROOT)
        IF (NEXT(P).EQ.SBROOT) TREE(3,P)=PREV(P)*46340+NEXT(SBROOT)
        TREE(1,SBROOT)=NTYPE(SBROOT)
        TREE(3,SBROOT)=SBROOT*46340
 
        END
C ----------------------------------------------------------------------
C
C       Z Y D O W N   -   Return down pointer of a node
C
 
        INTEGER FUNCTION ZYDOWN(NODE)
        INTEGER NODE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        ZYDOWN=TREE(2,NODE)
 
        END
C ----------------------------------------------------------------------
C
C       Z Y F S Y M   -   Find Symbol (with a particular name)
C
 
        INTEGER FUNCTION ZYFSYM(TEXT,PUN,RESULT)
        INTEGER TEXT(*),PUN,RESULT(8)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
        INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
 
        SAVE /XCSTRI/
 
 
        INTEGER I
 
        INTEGER EQUAL
        EXTERNAL EQUAL,ERROR
 
        IF (PUN.GT.NPUS) CALL ERROR('ZYFSYM: NONEXISTENT P..U..')
 
C First find the first symbol in that program-unit
        ZYFSYM=PUIDX(MIN(250,PUN))-1
 100    ZYFSYM=ZYFSYM+1
        IF (SYMBOL(3,ZYFSYM).NE.PUN .AND.
     +      ZYFSYM.LT.NSYMS) GOTO 100
        IF (SYMBOL(3,ZYFSYM).NE.PUN)
     +      CALL ERROR('ZYFSYM: PROGRAM-UNIT NOT FOUND')
 
C Found start of symbols for that p.u. - look for the one we want
 200    IF (SYMBOL(3,ZYFSYM).EQ.PUN .AND.
     +      EQUAL(STRTXT(SYMBOL(2,ZYFSYM)),TEXT).EQ.-2) THEN
            DO 300 I=1,8
 300            RESULT(I)=SYMBOL(I,ZYFSYM)
        ELSE IF (ZYFSYM.LT.NSYMS) THEN
            ZYFSYM=ZYFSYM+1
            IF (SYMBOL(3,ZYFSYM-1).EQ.PUN) GOTO 200
            IF (MODFLG) GOTO 200
            ZYFSYM=-1
        ELSE
            ZYFSYM=-1
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       Z Y G D S D   -   Get Declaration Standardiser Data
C
 
        SUBROUTINE ZYGDSD(SYMIDX,STYPE,SDTYPE,SCHLEN,SBITS,N)
        INTEGER N
        INTEGER SYMIDX(N),STYPE(N),SDTYPE(N),SCHLEN(N),SBITS(N)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
        INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
 
        SAVE /XCSTRI/
 
 
        INTEGER I,II
 
        INTEGER ZIAND
        EXTERNAL ZIAND,ZCHOUT,PUTLIN,ZMESS
 
        DO 100 II=1,N
            I=SYMIDX(II)
            IF (SYMBOL(1,I).EQ.1) THEN
                SDTYPE(II)=0
                SCHLEN(II)=0
                SBITS(II)=0
                STYPE(II)=20
            ELSE IF (SYMBOL(1,I).EQ.2) THEN
                SDTYPE(II)=0
                SCHLEN(II)=0
                SBITS(II)=0
                STYPE(II)=13
            ELSE
                SBITS(II)=SYMBOL(6,I)
                SDTYPE(II)=SYMBOL(4,I)
                SCHLEN(II)=SYMBOL(5,I)
                IF (SYMBOL(1,I).EQ.6) THEN
                    STYPE(II)=1
                ELSE IF (SYMBOL(1,I).EQ.7) THEN
                    STYPE(II)=10
                    IF (SYMBOL(4,I).EQ.-1)
     +                  STYPE(II)=11
                    IF (ZIAND(SYMBOL(6,I),
     +                        4096+2).NE.0)
     +                  STYPE(II)=12
                    IF (ZIAND(SYMBOL(6,I),4).NE.0)
     +                  STYPE(II)=STYPE(II)-6
                ELSE IF (SYMBOL(1,I).EQ.8) THEN
                    STYPE(II)=14
                ELSE IF (SYMBOL(1,I).EQ.4) THEN
                    STYPE(II)=0
                ELSE IF (SYMBOL(1,I).EQ.9) THEN
                    STYPE(II)=15
                ELSE
                    IF (SYMBOL(1,I).NE.5 .AND.
     +                  SYMBOL(1,I).NE.3) THEN
                        CALL ZCHOUT('ZYGDSD: Strange item found - "',
     +                              2)
                        CALL PUTLIN(STRTXT(SYMBOL(2,I)),2)
                        CALL ZMESS('"',2)
                    END IF
                    STYPE(II)=8
                    IF (SYMBOL(7,I).NE.0) STYPE(II)=STYPE(II)+1
                    IF (ZIAND(SYMBOL(6,I),4).NE.0)
     +                  STYPE(II)=STYPE(II)-6
                    IF (ZIAND(SYMBOL(6,I),1024).NE.0)
     +                  STYPE(II)=STYPE(II)-2
                END IF
            END IF
 100    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       Z Y G N S W   -   Get Next Symbol Within program-unit
C
 
        INTEGER FUNCTION ZYGNSW(SYMPTR,PUN,RESULT)
        INTEGER SYMPTR,PUN,RESULT(8)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        INTEGER I
 
        ZYGNSW=-100
        IF (SYMPTR.EQ.0) SYMPTR=PUIDX(MIN(PUN,NPUS,250))-1
 100    SYMPTR=SYMPTR+1
        IF (SYMPTR.GT.NSYMS) RETURN
        IF (SYMBOL(3,SYMPTR).LT.PUN) GOTO 100
        IF (SYMBOL(3,SYMPTR).NE.PUN) THEN
            IF (MODFLG) GOTO 100
            RETURN
        END IF
        DO 200 I=1,8
 200        RESULT(I)=SYMBOL(I,SYMPTR)
        ZYGNSW=-2
 
        END
C ----------------------------------------------------------------------
C
C       Z Y G N S Y   -   Get Next Symbol
C
 
        INTEGER FUNCTION ZYGNSY(SYMPTR,RESULT)
        INTEGER SYMPTR,RESULT(8)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        INTEGER I
 
        SYMPTR=SYMPTR+1
        IF (SYMPTR.GT.NSYMS) THEN
            ZYGNSY=-100
        ELSE
            DO 100 I=1,8
 100            RESULT(I)=SYMBOL(I,SYMPTR)
            ZYGNSY=-2
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       Z Y G S S I   -   Get Sorted Symbol Index - This is DECS' vers.,
C                         and cheats by not returning "in_include" syms.
C
C       NOTE: This all relies on the field "common_size" (which is in
C             the same position as the "name_status" field for vars)
C             being zero for common blocks after parsing - it should
C             still work after static semantic analysis, even though this
C             sets the value of this field (to the size of the common
C             common block in char storage units) unless the common is
C             very big (2097152 char storage units or larger - i.e. more
C             than 2 MB in a single common block).
C
 
        SUBROUTINE ZYGSSI(SYMIDX,N,PUN)
        INTEGER SYMIDX(*),N,PUN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
        INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
 
        SAVE /XCSTRI/
 
 
        INTEGER I,L,R,O,SYM
 
        INTEGER ZORDER,ZIAND
        EXTERNAL ZORDER,ZIAND
 
        N=0
        SYM=PUIDX(MIN(PUN,NPUS,250))-1
 
 100    SYM=SYM+1
        IF (SYMBOL(3,SYM).LT.PUN .AND. SYM.LT.NSYMS) GOTO 100
 
 200    IF (SYMBOL(3,SYM).EQ.PUN .AND.
     +      ZIAND(SYMBOL(6,SYM),2097152).NE.0) THEN
            SYM=SYM+1
            IF (SYM.LE.NSYMS) GOTO 200
        ELSE IF (SYMBOL(3,SYM).EQ.PUN) THEN
            N=N+1
            IF (N.EQ.1) THEN
                SYMIDX(1)=SYM
            ELSE
C Use binary insertion
                L=1
                R=N-1
C While (l<=r) do
 300            I=(L+R)/2
                O=ZORDER(STRTXT(SYMBOL(2,SYM)),
     +                   STRTXT(SYMBOL(2,SYMIDX(I))))
                IF (O.EQ.60) THEN
                    R=I-1
                ELSE
                    L=I+1
                END IF
                IF (L.LE.R) GOTO 300
C od
                DO 400 I=N-1,L,-1
 400                SYMIDX(I+1)=SYMIDX(I)
                SYMIDX(L)=SYM
            END IF
            SYM=SYM+1
            IF (SYM.LE.NSYMS) GOTO 200
        ELSE IF (MODFLG) THEN
            SYM=SYM+1
            IF (SYM.LE.NSYMS) GOTO 200
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       Z Y G T S T   -   Get string from string pointer
C
 
        SUBROUTINE ZYGTST(STRPTR,TEXT)
        INTEGER STRPTR,TEXT(*)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
        INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
 
        SAVE /XCSTRI/
 
 
        EXTERNAL SCOPY
 
        CALL SCOPY(STRTXT,STRPTR,TEXT,1)
 
        END
C ----------------------------------------------------------------------
C
C       Z Y G T S Y   -   Get Symbol
C
 
        SUBROUTINE ZYGTSY(SYMPTR,RESULT)
        INTEGER SYMPTR,RESULT(8)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        INTEGER I
 
        DO 100 I=1,8
 100        RESULT(I)=SYMBOL(I,SYMPTR)
 
        END
C ----------------------------------------------------------------------
C
C       Z Y I N C I   -   Input Comment Index
C
 
        INTEGER FUNCTION ZYINCI(FD)
        INTEGER FD
        INTEGER IODCMT,STMTNO,BUFF(*)
 
        INTEGER CIOVFP,CISIZE,BIGNUM
        PARAMETER (CIOVFP=150,CISIZE=300,BIGNUM=1000000)
 
C CISIZE = maximum in-memory index size
C CIOVFP = overflow point (only when really big)
C BIGNUM = a number which is bigger than any conceivable statement no.
 
        INTEGER IODCI,MEMCI(3,CISIZE),NINMEM,BUFFER(134),STATUS,I,
     +          PNTR,CURCMT,LOWEST,LAST
        LOGICAL FETCH
 
        SAVE
 
        INTEGER ZYGTCM,ZYGNCM,ZYCMEX
 
        INTEGER CTOI,ZGTCMD,XCMTRD
        EXTERNAL CTOI,ZGTCMD,SEEK
 
C Index structure:  (1,*)=statement number
C                   (2,*)=first comment number
C                   (3,*)=last comment number
C
C Up to NINMEM: current "in-memory" index
C From NINMEM+1 to OVFMAX: overflow area
C BIG: whether there is an overflow area or not
 
        IODCI=FD
        NINMEM=0
        MEMCI(1,1)=0
        LAST=BIGNUM
 
 100    STATUS=ZGTCMD(BUFFER,IODCI)
        IF (STATUS.EQ.-1) CALL ERROR('I/O Error reading comment index')
        IF (STATUS.NE.-100) THEN
            PNTR=1
            NINMEM=NINMEM+1
            MEMCI(1,NINMEM)=CTOI(BUFFER,PNTR)
            MEMCI(2,NINMEM)=CTOI(BUFFER,PNTR)
            MEMCI(3,NINMEM)=CTOI(BUFFER,PNTR)
            IF (NINMEM.LT.CISIZE) GO TO 100
C We have overflowed - remember it!
            LAST=MEMCI(1,CISIZE)
        END IF
        LOWEST=1
        ZYINCI=-2
        RETURN
 
        ENTRY ZYGTCM(IODCMT,STMTNO,BUFF)
 
        FETCH=.TRUE.
        GOTO 200
 
        ENTRY ZYCMEX(STMTNO)
 
        FETCH=.FALSE.
 
C Find the index entry ...
C ... first see if we need to load a different index
 
 200    IF (STMTNO.LT.LOWEST .OR. STMTNO.GT.LAST) THEN
            IF (STMTNO.LT.LOWEST) THEN
                IF (STMTNO.LE.0)
     +              CALL ERROR('ZYGTCM: NON-POSITIVE STMT NUMBER')
C Clear entire index and refill from the bottom
                CALL SEEK(0,IODCI)
                LOWEST=0
                NINMEM=0
            ELSE IF (STMTNO.GT.LAST) THEN
C Clear lower portion and replace with the next higher portion
C ... do it by moving higher portion down ...
                LOWEST=MEMCI(1,CIOVFP)+1
                DO 300 I=1,CIOVFP
                    MEMCI(1,I)=MEMCI(1,I+CIOVFP)
                    MEMCI(2,I)=MEMCI(2,I+CIOVFP)
                    MEMCI(3,I)=MEMCI(3,I+CIOVFP)
 300            CONTINUE
                NINMEM=CIOVFP
            END IF
 400        STATUS=ZGTCMD(BUFFER,IODCI)
            IF (STATUS.NE.-100) THEN
                NINMEM=NINMEM+1
                PNTR=1
                MEMCI(1,NINMEM)=CTOI(BUFFER,PNTR)
                MEMCI(2,NINMEM)=CTOI(BUFFER,PNTR)
                MEMCI(3,NINMEM)=CTOI(BUFFER,PNTR)
                IF (NINMEM.LT.CISIZE) GOTO 400
            END IF
            LAST=MEMCI(1,NINMEM)
            IF (STATUS.EQ.-100) LAST=BIGNUM
            GOTO 200
        END IF
 
C Loaded correct part of index - see if it is there
 
        I=0
 500    I=I+1
        IF (MEMCI(1,I).LT.STMTNO .AND. I.LT.NINMEM) GOTO 500
 
C Found it or it isn't there - return comment or status
C as appropriate
 
        IF (FETCH) THEN
            IF (MEMCI(1,I).EQ.STMTNO) THEN
                CURCMT=MEMCI(2,I)
                ZYGTCM=XCMTRD(IODCMT,CURCMT,BUFF)
            ELSE
                ZYGTCM=-100
            END IF
        ELSE
            IF (MEMCI(1,I).EQ.STMTNO) THEN
                ZYCMEX=-2
            ELSE
                ZYCMEX=-3
            END IF
        END IF
        RETURN
 
        ENTRY ZYGNCM(IODCMT,BUFF)
 
        IF (CURCMT.EQ.MEMCI(3,I)) THEN
            ZYGNCM=-100
        ELSE
            CURCMT=CURCMT+1
            ZYGNCM=XCMTRD(IODCMT,CURCMT,BUFF)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       X C M T R D   -   (internal) read comment file
C
 
        INTEGER FUNCTION XCMTRD(IODCMT,CMTNUM,BUFFER)
        INTEGER IODCMT,CMTNUM,BUFFER(*)
 
        INTEGER CHSIZE
        PARAMETER (CHSIZE=10)
 
        INTEGER LSTCMT,CACHE(0:134,CHSIZE),I,CHNUM
 
        SAVE LSTCMT,CACHE,CHNUM
 
        INTEGER XXCMRD,XCMREW
        EXTERNAL ERROR,SCOPY
 
        DATA LSTCMT/-1/,CHNUM/1/
 
        IF (LSTCMT.EQ.-1) THEN
            LSTCMT=0
            DO 100 I=1,CHSIZE
                CACHE(0,I)=0
 100        CONTINUE
        ELSE IF (LSTCMT.NE.CMTNUM-1) THEN
            DO 200 I=1,CHSIZE
                IF (CMTNUM.EQ.CACHE(0,I)) THEN
                    CALL SCOPY(CACHE(1,I),1,BUFFER,1)
                    XCMTRD=-2
                    RETURN
                END IF
 200        CONTINUE
        END IF
 
        IF (LSTCMT.GE.CMTNUM) THEN
            XCMTRD=XCMREW(IODCMT)
            IF (XCMTRD.NE.-2) CALL ERROR('Unexpected Error from XCMREW')
            LSTCMT=0
        END IF
 
 300    CONTINUE
        LSTCMT=LSTCMT+1
        IF (LSTCMT.LT.CMTNUM) THEN
            CHNUM=MOD(CHNUM,CHSIZE)+1
            CACHE(0,CHNUM)=LSTCMT
            XCMTRD=XXCMRD(CACHE(1,CHNUM),IODCMT)
            IF (XCMTRD.EQ.-2) GOTO 300
        ELSE
            XCMTRD=XXCMRD(BUFFER,IODCMT)
        END IF
        IF (XCMTRD.EQ.-100) THEN
            CALL ERROR('Internal Error: end-of-file reading comments')
        ELSE IF (XCMTRD.EQ.-1) THEN
            CALL ERROR('I/O er'//'ror reading comments')
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       X X C M R D   -   Even more internal "read comment file"
C
C       Just reads the next comment from the comment file
C
C       Also provides an ENTRY point for rewinding it
C
 
        INTEGER FUNCTION XXCMRD(BUFFER,IODCMT)
 
        INTEGER XCMREW
 
        INTEGER BUFFER(*),IODCMT
 
        INTEGER LIMIT,SIZE
        PARAMETER (LIMIT=132, SIZE=LIMIT+2)
 
        INTEGER POINTR,IBUFF(SIZE),I,FIRST,SECOND,LENT,C
 
        SAVE POINTR,IBUFF
 
        EXTERNAL SEEK,XTKSUB
 
        DATA POINTR/SIZE/
 
 100    CONTINUE
        CALL XTKSUB(FIRST,POINTR,IBUFF,LIMIT,IODCMT,XXCMRD)
        IF (XXCMRD.NE.-2) RETURN
        CALL XTKSUB(SECOND,POINTR,IBUFF,LIMIT,IODCMT,XXCMRD)
        IF (XXCMRD.NE.-2) RETURN
 
        LENT = (FIRST-48)*10+SECOND-48
        DO 200 I=1,LENT
            CALL XTKSUB(C,POINTR,IBUFF,LIMIT,IODCMT,XXCMRD)
            IF (XXCMRD.NE.-2) RETURN
            BUFFER(I) = C
 200    CONTINUE
        BUFFER(I) = 129
        IF (BUFFER(1).EQ.36) GO TO 100
 
        RETURN
 
        ENTRY XCMREW(IODCMT)
 
        CALL SEEK(0,IODCMT)
        POINTR=SIZE
        XCMREW=-2
 
        END
C ----------------------------------------------------------------------
C
C       Z Y I N P T   -   Input parse tree from file
C
 
        SUBROUTINE ZYINPT(IOD)
        INTEGER IOD
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        INTEGER TYPE,DOWN,NEXT,PREV,UP,STATUS,BUFF(134),PNTR,I,EXTN
 
        INTEGER GETLIN,ZSCTOI
        EXTERNAL GETLIN,ZSCTOI,ERROR
 
        STATUS=GETLIN(BUFF,IOD)
        PNTR=1
        ROOT=ZSCTOI(BUFF,PNTR)
        TRETOP=ZSCTOI(BUFF,PNTR)
 
        DO 100 I=1,TRETOP
            IF (MOD(I,3).EQ.1) THEN
                STATUS=GETLIN(BUFF,IOD)
                IF (STATUS.EQ.-100)
     +              CALL ERROR('Invalid parse tree file')
                PNTR=1
            END IF
            TYPE=ZSCTOI(BUFF,PNTR)
            DOWN=ZSCTOI(BUFF,PNTR)
            NEXT=ZSCTOI(BUFF,PNTR)
            PREV=ZSCTOI(BUFF,PNTR)
            UP=ZSCTOI(BUFF,PNTR)
            IF (BUFF(PNTR).EQ.129) CALL ERROR('Corrupt parse tree file')
            EXTN=ZSCTOI(BUFF,PNTR)
            TREE(1,I)=TYPE+46340*UP
            TREE(2,I)=DOWN
            TREE(3,I)=NEXT+46340*PREV
            TREE(4,I)=EXTN
 100    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       Z Y I N S Y   -   Input symbol table (including strings)
C
 
        SUBROUTINE ZYINSY(IOD)
        INTEGER IOD
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
        INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
 
        SAVE /XCSTRI/
 
 
        INTEGER STATUS,BUFF(134),INCHAR,PNTR,I,J,STRNUM,
     +          BUFPTR
        LOGICAL FSTEMS
 
        INTEGER GETLIN,ZSCTOI
        EXTERNAL GETLIN,ZSCTOI,ZMESS,ZCHOUT,PUTLIN,ERROR,REMARK
 
C
C Input the string table (There may be error/warning messages)
C
        FSTEMS=.TRUE.
 100    STATUS=GETLIN(BUFF,IOD)
        IF (BUFF(1).EQ.69 .OR. BUFF(1).EQ.87) THEN
            IF (FSTEMS) THEN
                CALL ZMESS('Source program has errors/warnings:',2)
                FSTEMS=.FALSE.
            END IF
            CALL ZCHOUT('   ',2)
            CALL PUTLIN(BUFF,2)
            GOTO 100
        END IF
        PNTR=1
        NSTRNG=ZSCTOI(BUFF,PNTR)
C All programs have at least one string - the p.u. name!!!
        IF (NSTRNG.EQ.0) CALL ERROR('ZYINSY: Not a symbol table file')
        TXTTOP=ZSCTOI(BUFF,PNTR)
        STRNUM=0
        STRTBL(1)=1
        BUFPTR=0
 
        DO 400 I=1,TXTTOP-1
            IF (BUFPTR.EQ.0) THEN
                STATUS=GETLIN(BUFF,IOD)
                DO 200 J=STATUS,132
 200                BUFF(J)=32
                BUFF(132+1)=129
                BUFPTR=1
            END IF
            INCHAR=BUFF(BUFPTR)
            BUFPTR=MOD(BUFPTR+1,132+1)
            IF (INCHAR.EQ.39) THEN
                INCHAR=0
            ELSE IF (INCHAR.EQ.47) THEN
                IF (BUFPTR.EQ.0) THEN
                    STATUS=GETLIN(BUFF,IOD)
                    DO 300 J=STATUS,132
 300                    BUFF(J)=32
                     BUFF(132+1)=129
                    BUFPTR=1
                END IF
                INCHAR=BUFF(BUFPTR)
                BUFPTR=MOD(BUFPTR+1,132+1)
            END IF
            IF (INCHAR.EQ.0) THEN
                STRNUM=STRNUM+1
                STRTBL(STRNUM+1)=I+1
                STRTXT(I)=129
            ELSE
                STRTXT(I)=INCHAR
            END IF
 400    CONTINUE
        IF (STRNUM.NE.NSTRNG) CALL ERROR('Inconsistent string table')
        IF (STRTXT(TXTTOP-1).NE.129) CALL ERROR('Corrupted symbol file')
 
C
C Input the symbol table
C
        STATUS=GETLIN(BUFF,IOD)
        IF (STATUS.LT.-2) CALL ERROR('Incomplete symbol table file')
        PNTR=1
        NSYMS=ZSCTOI(BUFF,PNTR)
        NPUS=ZSCTOI(BUFF,PNTR)
        IF (ZSCTOI(BUFF,PNTR).NE.250)
     +      CALL ERROR('Incompatible format of symbol table file')
        MODFLG=ZSCTOI(BUFF,PNTR).EQ.1
        IF (BUFF(PNTR-1).NE.48 .AND. .NOT.MODFLG) THEN
            CALL REMARK('Old symbol table format - continuing')
            MODFLG=.TRUE.
        END IF
        DO 600 I=1,NSYMS
            IF (MOD(I,2).EQ.1) THEN
                STATUS=GETLIN(BUFF,IOD)
                IF (STATUS.EQ.-100)
     +              CALL ERROR('Unexpected end of symbol file')
                PNTR=1
            END IF
            DO 500 J=1,8
                SYMBOL(J,I)=ZSCTOI(BUFF,PNTR)
 500        CONTINUE
 600    CONTINUE
        IF (SYMBOL(1,NSYMS).EQ.0) CALL ERROR('Invalid symbol table')
C
C Input the Program-Unit Index
C
        DO 700 I=1,MIN(NPUS,250)
            IF (MOD(I,22).EQ.1) THEN
                STATUS=GETLIN(BUFF,IOD)
                IF (STATUS.EQ.-100)
     +              CALL ERROR('Unexpected end of symbol file')
                PNTR=1
            END IF
            PUIDX(I)=ZSCTOI(BUFF,PNTR)
 700    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       Z Y N E X T   -   Return next pointer of a node
C
 
        INTEGER FUNCTION ZYNEXT(NODE)
        INTEGER NODE
 
        INTRINSIC MOD
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        ZYNEXT=MOD(TREE(3,NODE),46340)
 
        END
C ----------------------------------------------------------------------
C
C       Z Y N T Y P   -   Return type of a node
C
 
        INTEGER FUNCTION ZYNTYP(NODE)
        INTEGER NODE
 
        INTRINSIC MOD
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        ZYNTYP=MOD(TREE(1,NODE),46340)
 
        END
C ----------------------------------------------------------------------
C
C       Z Y P R E V   -   Return previous pointer of a node
C
 
        INTEGER FUNCTION ZYPREV(NODE)
        INTEGER NODE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        ZYPREV=TREE(3,NODE)/46340
 
        END
C ----------------------------------------------------------------------
C
C       Z Y R E P L   -   Replace node
C
 
        SUBROUTINE ZYREPL(N1,N2)
        INTEGER N1,N2
 
        CALL ZYADNX(N2,N1)
        CALL ZYDELT(N1)
 
        END
C ----------------------------------------------------------------------
C
C       Z Y R O O T   -   Return number of root node of parse tree
C
 
        INTEGER FUNCTION ZYROOT()
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        ZYROOT=ROOT
 
        END
C ----------------------------------------------------------------------
C
C       Z Y S A B T   -   Set atttibute bits
C
 
        SUBROUTINE ZYSABT(SYMPTR,ATTNUM,BITS)
        INTEGER SYMPTR,ATTNUM,BITS
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        INTEGER ZIOR
        EXTERNAL ZIOR
 
        SYMBOL(ATTNUM,SYMPTR)=ZIOR(SYMBOL(ATTNUM,SYMPTR),BITS)
 
        END
C ----------------------------------------------------------------------
C
C       Z Y S A T T   -   Set symbol Attribute (overrides current value)
C
 
        SUBROUTINE ZYSATT(SYMPTR,ATTNUM,VALUE)
        INTEGER SYMPTR,ATTNUM,VALUE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        SYMBOL(ATTNUM,SYMPTR)=VALUE
 
        END
C ----------------------------------------------------------------------
C
C       Z Y T O U T   -   Output parse tree
C
 
        SUBROUTINE ZYTOUT(IOD)
        INTEGER IOD
 
        INTEGER I
 
        EXTERNAL ZPTINT,PUTCH,CLOSE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
C
C Output header
C
        CALL ZPTINT(ROOT,1,IOD)
        CALL PUTCH(32,IOD)
        CALL ZPTINT(TRETOP,1,IOD)
        CALL PUTCH(10,IOD)
C
C Output tree
C
        DO 100 I=1,TRETOP
            CALL ZPTINT(NTYPE(I),1,IOD)
            CALL PUTCH(32,IOD)
            CALL ZPTINT(DOWN(I),1,IOD)
            CALL PUTCH(32,IOD)
            CALL ZPTINT(NEXT(I),1,IOD)
            CALL PUTCH(32,IOD)
            CALL ZPTINT(PREV(I),1,IOD)
            CALL PUTCH(32,IOD)
            CALL ZPTINT(UP(I),1,IOD)
            CALL PUTCH(32,IOD)
            CALL ZPTINT(NATTR(I),1,IOD)
            IF (MOD(I,3).EQ.0) THEN
                CALL PUTCH(10,IOD)
            ELSE
                CALL PUTCH(32,IOD)
            END IF
 100    CONTINUE
        IF (MOD(TRETOP,3).NE.0) CALL PUTCH(10,IOD)
        CALL CLOSE(IOD)
 
        END
C ----------------------------------------------------------------------
C
C       Z Y S O U T   -   Output symbol table (and strings)
C
 
        SUBROUTINE ZYSOUT(IOD)
        INTEGER IOD
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
        INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
 
        SAVE /XCSTRI/
 
 
        INTEGER BUFF(134),BPNTR,SPNTR,I,J
 
        EXTERNAL PUTLIN,ZPTINT,PUTCH,CLOSE,ZMESS
 
C
C Write out the string table to the front of the symbol table file
C
 
        CALL ZPTINT(NSTRNG,1,IOD)
        CALL PUTCH(32,IOD)
        CALL ZPTINT(TXTTOP,1,IOD)
        CALL PUTCH(10,IOD)
        BPNTR=0
        DO 100 SPNTR=1,TXTTOP-1
            BPNTR=BPNTR+1
 
            IF (STRTXT(SPNTR).EQ.129) THEN
                BUFF(BPNTR)=39
            ELSE IF (STRTXT(SPNTR).EQ.39) THEN
                BUFF(BPNTR)=47
            ELSE
                BUFF(BPNTR)=STRTXT(SPNTR)
            END IF
            IF (BPNTR.EQ.132) THEN
                BUFF(BPNTR+1)=10
                BUFF(BPNTR+2)=129
                CALL PUTLIN(BUFF,IOD)
                BPNTR=0
            END IF
            IF (STRTXT(SPNTR).EQ.39 .OR. STRTXT(SPNTR).EQ.47)
     +      THEN
                BPNTR=BPNTR+1
                BUFF(BPNTR)=STRTXT(SPNTR)
                IF (BPNTR.EQ.132) THEN
                    BUFF(BPNTR+1)=10
                    BUFF(BPNTR+2)=129
                    CALL PUTLIN(BUFF,IOD)
                    BPNTR=0
                END IF
            END IF
 100    CONTINUE
        IF (BPNTR.GT.0) THEN
            BUFF(BPNTR+1)=10
            BUFF(BPNTR+2)=129
            CALL PUTLIN(BUFF,IOD)
        END IF
C
C Write the symbol table following the strings
C
 
        CALL ZPTINT(NSYMS,1,IOD)
        CALL PUTCH(32,IOD)
        CALL ZPTINT(NPUS,1,IOD)
        CALL PUTCH(32,IOD)
        CALL ZPTINT(250,1,IOD)
        CALL PUTCH(32,IOD)
        IF (MODFLG) THEN
            CALL ZMESS('1',IOD)
        ELSE
            CALL ZMESS('0',IOD)
        END IF
        DO 300 I=1,NSYMS
            DO 200 J=1,8
                CALL ZPTINT(SYMBOL(J,I),1,IOD)
                CALL PUTCH(32,IOD)
 200        CONTINUE
            IF (MOD(I,2).EQ.0) CALL PUTCH(10,IOD)
 300    CONTINUE
        IF (MOD(NSYMS,2).NE.0) CALL PUTCH(10,IOD)
C
C Write the program-unit index following the symbol table proper
C
        DO 400 I=1,MIN(250,NPUS)
            CALL ZPTINT(PUIDX(I),1,IOD)
            CALL PUTCH(32,IOD)
            IF (MOD(I,22).EQ.0) CALL PUTCH(10,IOD)
 400    CONTINUE
        CALL PUTCH(10,IOD)
C
C Finished
C
        CALL CLOSE(IOD)
 
        END
C ----------------------------------------------------------------------
C
C       Z Y U P   -   Return up pointer of a node
C
 
        INTEGER FUNCTION ZYUP(NODE)
        INTEGER NODE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        ZYUP=TREE(1,NODE)/46340
 
        END
C ----------------------------------------------------------------------
C
C       Z Y N N A M   -   Return node name as a character string
C
 
        CHARACTER*11 FUNCTION ZYNNAM(NUMBER)
        INTEGER NUMBER
 
        CHARACTER*11 NNAMES(0:132)
 
        DATA NNAMES/'ERROR','ROOT','MAIN','F_SUBP','S_SUBP',
     +'BD_SUBP','END','PROGRAM','FUNCTION','INTEGER','REAL','DOUBLE',
     +'COMPLEX','LOGICAL','CHARACTER','LIST','SUBROUTINE','ASTERISK',
     +'ENTRY','BLOCK_DATA','DIMENSION','ARR_DECLR','ARDIM','DARDIM',
     +'EQUIVALENCE','EQVSET','COMMON','BLNKCM','LBLDCM','CBITEMS',
     +'TYPE','CHAR_LEN','IMPLICIT','IMPL_DECL','CHAR_RANGE','PARAMETER',
     +'PARAM DECL','EXTERNAL','INTRINSIC','SAVE','CBLK NAME','DATA',
     +'DATA_DECL','DATA_ITEMS','DATA_VALS','MULT_VAL','NEG',
     +'DATA_IMPDO','DOSPEC','ASGN','ASSIGN','GOTO','CMGOTO','ASGOTO',
     +'LABELLIST','ARITHIF','LOG_IF','BLOCKIF','ELSEIF','ELSE','ENDIF',
     +'DO','CONTINUE','STOP','PAUSE','WRITE','READ','PRINT','CILIST',
     +'CIITEM','CONCAT','IOIMDL','OPEN','CLOSE','INQUIRE','BACKSPACE',
     +'ENDFILE','REWIND','FORMAT','REPEAT','SLASH','COLON','CALL',
     +'RETURN','.EQV.','.NEQV.','.OR.','.AND.','.NOT.','.LT.','.LE.',
     +'.EQ.','.NE.','.GT.','.GE.','PLUS','MINUS','POS','MULTIPLY',
     +'DIVIDE','EXPONT','SPAREN','CCONST','SUBSTR','ARELM','SSSPEC',
     +'DEFAULT','ICONST','NAME','LCONST','RCONST','DPCONST','FMTFLD',
     +'HCONST','SCONST','LABEL','LABELREF','SUBFMT','IOKW','FUNREF',
     +'IMPCHAR','STMT_FN','UNIT=','FMT=','AMBIGUOUS','DCMPLX','SCALE',
     +'INCL_EQUIV','INCL_DATA','INCL_COMM','INCL_SAVE','COMMENT','DMY'/
 
        IF (NUMBER.GE.0 .AND. NUMBER.LE.132) THEN
            ZYNNAM=NNAMES(NUMBER)
        ELSE
            ZYNNAM='Invalid arg'
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       Z Y S E R R   -   Signal a symbol error (possibly fatal)
C
 
        SUBROUTINE ZYSERR(ERRMSG,SYMPTR,FATAL)
        CHARACTER*(*) ERRMSG
        INTEGER SYMPTR
        LOGICAL FATAL
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
        INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
 
        SAVE /XCSTRI/
 
 
        EXTERNAL ZCHOUT,PUTLIN,PUTCH,ERROR
 
        CALL ZCHOUT(ERRMSG,2)
        CALL ZCHOUT(' - ',2)
        CALL PUTLIN(STRTXT(SYMBOL(2,SYMPTR)),2)
        CALL PUTCH(10,2)
        IF (FATAL) CALL ERROR('Fatal Error: Program Aborted')
 
        END
C ----------------------------------------------------------------------
C
C       Z Y A D S N   -   Add a subnode (becomes the last subnode)
C
 
        SUBROUTINE ZYADSN(NODE,SUB)
        INTEGER NODE,SUB
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
        IF (UP(SUB).NE.0) CALL ZYDELT(SUB)
        IF (DOWN(NODE).GT.0) THEN
            CALL ZYADNX(SUB,PREV(DOWN(NODE)))
        ELSE
            TREE(1,SUB)=MOD(TREE(1,SUB),46340)+46340*NODE
            CALL ZYCHDN(NODE,SUB)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       Z Y G P U S   -   Get Program-Unit Symbol pointer
C
 
        INTEGER FUNCTION ZYGPUS(PUN)
        INTEGER PUN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        IF (PUN.GT.NPUS) THEN
            ZYGPUS=-100
        ELSE
            ZYGPUS=PUIDX(MIN(PUN,22))
 100        IF (SYMBOL(3,ZYGPUS).NE.PUN .OR.
     +          SYMBOL(1,ZYGPUS).NE.4) THEN
                ZYGPUS=ZYGPUS+1
                GOTO 100
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       Z Y P U S Y   -   Like ZYGPUS, but from program-unit root node
C
 
        INTEGER FUNCTION ZYPUSY(PUROOT)
        INTEGER PUROOT
 
        INTEGER PTR,PUNUM
 
        INTEGER ZYGPUS
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
        PTR=DOWN(PUROOT)
        IF (NTYPE(PTR).EQ.7 .OR.
     +      NTYPE(PTR).EQ.16 .OR.
     +      NTYPE(PTR).EQ.8 .OR.
     +      NTYPE(PTR).EQ.19 .AND. DOWN(PTR).NE.0) THEN
            PTR=DOWN(PTR)
            IF (NTYPE(PTR).NE.108) PTR=NEXT(PTR)
            IF (NTYPE(PTR).NE.108) PTR=NEXT(PTR)
            ZYPUSY=-DOWN(PTR)
        ELSE
            PTR=DOWN(UP(PUROOT))
            PUNUM=1
 100        IF (PTR.NE.PUROOT) THEN
                PTR=NEXT(PTR)
                GOTO 100
            END IF
            ZYPUSY=ZYGPUS(PUNUM)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       Z Y C S D T   -   Canonicalise Symbol Data Types
C
 
        SUBROUTINE ZYCSDT(CAFORM,ALL)
        INTEGER CAFORM
        LOGICAL ALL
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        INTEGER I
 
        DO 100 I=1,NSYMS
            IF (SYMBOL(1,I).GE.3) THEN
                IF (SYMBOL(4,I).EQ.2) THEN
 
C REAL --> REAL*4 [if "lenspecs"]
 
                    IF (CAFORM.EQ.2 .AND.
     +                  SYMBOL(5,I).EQ.0)
     +                  SYMBOL(5,I)=4
 
C REAL*4 --> REAL [unless "lenspecs"]
 
                    IF (CAFORM.NE.2) THEN
                        IF (SYMBOL(5,I).EQ.4)
     +                      SYMBOL(5,I)=0
 
C REAL*8 --> DOUBLE PRECISION [unless "lenspecs"]
 
                        IF (SYMBOL(5,I).EQ.2*4) THEN
                            SYMBOL(4,I)=5
                            SYMBOL(5,I)=0
                        END IF
                    END IF
                ELSE IF (SYMBOL(4,I).EQ.4) THEN
 
C COMPLEX --> COMPLEX*8 [if "lenspecs"]
 
                    IF (CAFORM.EQ.2 .AND.
     +                  SYMBOL(5,I).EQ.0)
     +                  SYMBOL(5,I)=2*4
 
C COMPLEX*8 --> COMPLEX [unless "lenspecs"]
 
                    IF (CAFORM.NE.2 .AND.
     +                  SYMBOL(5,I).EQ.2*4)
     +                  SYMBOL(5,I)=0
 
C COMPLEX*16 --> DOUBLE COMPLEX [if "keywords"]
 
                    IF (CAFORM.EQ.1 .AND.
     +                  SYMBOL(5,I).EQ.4*4) THEN
                        SYMBOL(4,I)=7
                        SYMBOL(5,I)=0
                    END IF
 
C DOUBLE PRECISION --> REAL*8 [if "lenspecs"]
 
                ELSE IF (SYMBOL(4,I).EQ.5 .AND.
     +                   CAFORM.EQ.2) THEN
                    SYMBOL(4,I)=2
                    SYMBOL(5,I)=2*4
 
C DOUBLE COMPLEX --> COMPLEX*16 [unless "keywords"]
 
                ELSE IF (SYMBOL(4,I).EQ.7 .AND.
     +                   CAFORM.NE.1) THEN
                    SYMBOL(4,I)=4
                    SYMBOL(5,I)=4*4
                ELSE IF (ALL) THEN
 
C *** Only do following transformations if "ALL" specified ***
 
                    IF (SYMBOL(4,I).EQ.1) THEN
 
C INTEGER --> INTEGER*4 [if "lenspecs"]
 
                        IF (CAFORM.EQ.2) THEN
                            IF (SYMBOL(5,I).EQ.0)
     +                          SYMBOL(5,I)=4
                        ELSE
 
C INTEGER*4 --> INTEGER [unless "lenspecs"]
 
                            IF (SYMBOL(5,I).EQ.4)
     +                          SYMBOL(5,I)=0
                        END IF
                    ELSE IF (SYMBOL(4,I).EQ.3) THEN
 
C LOGICAL --> LOGICAL*4 [if "lenspecs"]
 
                        IF (CAFORM.EQ.2) THEN
                            IF (SYMBOL(5,I).EQ.0)
     +                          SYMBOL(5,I)=4
                        ELSE
 
C LOGICAL*4 --> LOGICAL [unless "lenspecs"]
 
                            IF (SYMBOL(5,I).EQ.4)
     +                          SYMBOL(5,I)=0
                        END IF
                    ELSE IF (SYMBOL(4,I).EQ.6) THEN
 
C CHARACTER --> CHARACTER*1 [if "lenspecs"]
 
                        IF (CAFORM.EQ.2) THEN
                            IF (SYMBOL(5,I).EQ.0)
     +                          SYMBOL(5,I)=1
                        ELSE
 
C CHARACTER*1 --> CHARACTER [unless "lenspecs"]
 
                            IF (SYMBOL(5,I).EQ.1)
     +                          SYMBOL(5,I)=0
                        END IF
                    END IF
                END IF
            END IF
 100    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       Z Y C A D T   -   Return a canonical data type
C
C       For REAL*n, INTEGER*n, LOGICAL*n, COMPLEX*n, this returns the
C       single-value datatype code (used by ISTSA).
C
C       The value 0 (which is not a legal data type) is returned if the
C       DTYPE/CHRLEN combination is not legal.
C
C       "type_char" is returned for all CHARACTER types (the length is
C       ignored.
C
 
        INTEGER FUNCTION ZYCADT(DTYPE,CHRLEN)
        INTEGER DTYPE,CHRLEN
 
        ZYCADT=0
        IF (DTYPE.EQ.6 .OR. CHRLEN.EQ.0) THEN
            ZYCADT=DTYPE
        ELSE IF (DTYPE.EQ.2) THEN
            IF (CHRLEN.EQ.4) THEN
                ZYCADT=2
            ELSE IF (CHRLEN.EQ.2*4) THEN
                ZYCADT=5
            ELSE IF (CHRLEN.EQ.4*4) THEN
                ZYCADT=15
            END IF
        ELSE IF (DTYPE.EQ.1) THEN
            IF (2*CHRLEN.EQ.4) THEN
                ZYCADT=14
            ELSE IF (CHRLEN.EQ.4) THEN
                ZYCADT=1
            END IF
        ELSE IF (DTYPE.EQ.3) THEN
            IF (4*CHRLEN.EQ.4) THEN
                ZYCADT=12
            ELSE IF (2*CHRLEN.EQ.4) THEN
                ZYCADT=13
            ELSE IF (CHRLEN.EQ.4) THEN
                ZYCADT=3
            END IF
        ELSE IF (DTYPE.EQ.4) THEN
            IF (CHRLEN.EQ.2*4) THEN
                ZYCADT=4
            ELSE IF (CHRLEN.EQ.4*4) THEN
                ZYCADT=7
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       Z Y F D U P   -   Find duplicate symbol name (of common)
C
 
        INTEGER FUNCTION ZYFDUP(COMPTR)
        INTEGER COMPTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        EXTERNAL ERROR
 
        IF (COMPTR.LT.1 .OR. COMPTR.GT.NSYMS)
     +      CALL ERROR('ZYFDUP: Invalid argument')
        ZYFDUP=PUIDX(MIN(SYMBOL(3,COMPTR),22))
 100    IF (SYMBOL(3,ZYFDUP).NE.SYMBOL(3,COMPTR)) THEN
            ZYFDUP=ZYFDUP+1
            GOTO 100
        END IF
 200    IF (SYMBOL(3,ZYFDUP).EQ.SYMBOL(3,COMPTR) .AND.
     +      SYMBOL(2,ZYFDUP).EQ.SYMBOL(2,COMPTR) .AND.
     +      ZYFDUP.NE.COMPTR) RETURN
        ZYFDUP=ZYFDUP+1
        IF (ZYFDUP.LE.NSYMS .AND. (MODFLG .OR.
     +      SYMBOL(3,ZYFDUP-1).EQ.SYMBOL(3,COMPTR)))
     +      GOTO 200
        ZYFDUP=0
 
        END
C ----------------------------------------------------------------------
C
C       Z Y G E N L   -   Generate a label, unique within a program unit
C
 
        INTEGER FUNCTION ZYGENL(LABNUM,PUN)
        INTEGER LABNUM,PUN
 
        INTEGER RESULT(8),TEXT(6)
 
        INTRINSIC MOD
 
        INTEGER ZYFSYM,ITOC,ZYASTR,ZYASYM
        EXTERNAL ZYFSYM,ITOC,ZYASTR,ZYASYM
 
 100    LABNUM=MOD(LABNUM,99999)+1
        ZYGENL=ITOC(LABNUM,TEXT,6)
        ZYGENL=ZYFSYM(TEXT,PUN,RESULT)
        IF (ZYGENL.NE.-1) GOTO 100
        ZYGENL=ZYASYM(ZYASTR(TEXT),PUN,1)
 
        END
C ----------------------------------------------------------------------
C
C       Z Y S T X F    -   SeT eXtended Field
C
 
        SUBROUTINE ZYSTXF(NODE,XVALUE)
        INTEGER NODE,XVALUE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        TREE(4,NODE)=XVALUE
 
        END
C ----------------------------------------------------------------------
C
C       Z Y G T X F   -   GeT eXtended Field
C
 
        INTEGER FUNCTION ZYGTXF(NODE)
        INTEGER NODE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
        ZYGTXF=NATTR(NODE)
 
        END
C ----------------------------------------------------------------------
C
C       Z Y J M P A   -   Return a jump address (parse tree node number)
C                         from the label node referencing it.
C
 
        INTEGER FUNCTION ZYJMPA(NODE)
        INTEGER NODE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        EXTERNAL ERROR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
        IF (NTYPE(NODE).NE.116)
     +      CALL ERROR('INTERNAL ERROR: INVALID ARGUMENT TO ZYJMPA')
        ZYJMPA=SYMBOL(4,-DOWN(NODE))
 
        END
